home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / block.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  2.6 KB  |  124 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.  
  24.     block.c
  25.  
  26.     blocks and exits
  27. */
  28.  
  29. #include "include.h"
  30.  
  31.  
  32. Fblock(args)
  33. object args;
  34. {
  35.     object *oldlex = lex_env;
  36.     object id;
  37.     object body;
  38.     object *top;
  39.  
  40.     if(endp(args))
  41.         FEtoo_few_argumentsF(args);
  42.     lex_copy();
  43.     id = alloc_frame_id();
  44.     vs_push(id);
  45.     lex_block_bind(MMcar(args), id);
  46.     vs_pop;
  47.     frs_push(FRS_CATCH, id);
  48.     if (nlj_active)
  49.         nlj_active = FALSE;
  50.     else {
  51.         body = MMcdr(args);
  52.         if (endp(body)) {
  53.             vs_base = vs_top;
  54.             vs_push(Cnil);
  55.         } else {
  56.             top = vs_top;
  57.             do {
  58.                 vs_top = top;
  59.                 eval(MMcar(body));
  60.                 body = MMcdr(body);
  61.             } while (!endp(body));
  62.         }
  63.     }
  64.     frs_pop();
  65.     lex_env = oldlex;
  66. }
  67.  
  68. Freturn_from(args)
  69. object args;
  70. {
  71.     object lex_block;
  72.     frame_ptr fr;
  73.  
  74.     if (endp(args))
  75.         FEtoo_few_argumentsF(args);
  76.     if (!endp(MMcdr(args)) && !endp(MMcddr(args)))
  77.         FEtoo_many_argumentsF(args);
  78.     lex_block = lex_block_sch(MMcar(args));
  79.     if (MMnull(lex_block))
  80.         FEerror("The block name ~S is undefined.", 1, MMcar(args));
  81.     fr = frs_sch(MMcaddr(lex_block));
  82.     if(fr == NULL)
  83.         FEerror("The block ~S is missing.", 1, MMcar(args));
  84.     if(endp(MMcdr(args))) {
  85.         vs_base = vs_top;
  86.         vs_push(Cnil);
  87.     }
  88.     else
  89.         eval(MMcadr(args));
  90.     unwind(fr, MMcaddr(lex_block));
  91.     /*  never reached  */
  92. }
  93.  
  94. Freturn(args)
  95. object args;
  96. {
  97.     object lex_block;
  98.     frame_ptr fr;
  99.  
  100.     if(!endp(args) && !endp(MMcdr(args)))
  101.         FEtoo_many_argumentsF(args);
  102.     lex_block = lex_block_sch(Cnil);
  103.     if (MMnull(lex_block))
  104.          FEerror("The block name ~S is undefined.", 1, Cnil);
  105.     fr = frs_sch(MMcaddr(lex_block));
  106.     if (fr == NULL)
  107.         FEerror("The block ~S is missing.", 1, Cnil);
  108.     if(endp(args)) {
  109.         vs_base = vs_top;
  110.         vs_push(Cnil);
  111.     } else
  112.         eval(MMcar(args));
  113.     unwind(fr, MMcaddr(lex_block));
  114.     /*  never reached  */
  115. }
  116.  
  117. init_block()
  118. {
  119.     Sblock = make_special_form("BLOCK", Fblock);
  120.     enter_mark_origin(&Sblock);
  121.     make_special_form("RETURN-FROM", Freturn_from);
  122.     make_special_form("RETURN", Freturn);
  123. }
  124.